home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / cl / cl-seq.el.z / cl-seq.el
Encoding:
Text File  |  1998-05-21  |  37.3 KB  |  936 lines
  1. ;;; cl-seq.el --- Common Lisp extensions for GNU Emacs Lisp (part three)
  2.  
  3. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Dave Gillespie <daveg@synaptics.com>
  6. ;; Version: 2.02
  7. ;; Keywords: extensions
  8.  
  9. ;; This file is part of XEmacs.
  10.  
  11. ;; XEmacs is free software; you can redistribute it and/or modify it
  12. ;; under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; XEmacs is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24. ;; 02111-1307, USA.
  25.  
  26. ;;; Synched up with: FSF 19.34.
  27.  
  28. ;;; Commentary:
  29.  
  30. ;; These are extensions to Emacs Lisp that provide a degree of
  31. ;; Common Lisp compatibility, beyond what is already built-in
  32. ;; in Emacs Lisp.
  33. ;;
  34. ;; This package was written by Dave Gillespie; it is a complete
  35. ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
  36. ;;
  37. ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
  38. ;;
  39. ;; Bug reports, comments, and suggestions are welcome!
  40.  
  41. ;; This file contains the Common Lisp sequence and list functions
  42. ;; which take keyword arguments.
  43.  
  44. ;; See cl.el for Change Log.
  45.  
  46.  
  47. ;;; Code:
  48.  
  49. (or (memq 'cl-19 features)
  50.     (error "Tried to load `cl-seq' before `cl'!"))
  51.  
  52.  
  53. ;;; We define these here so that this file can compile without having
  54. ;;; loaded the cl.el file already.
  55.  
  56. (defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
  57. (defmacro cl-pop (place)
  58.   (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
  59.  
  60.  
  61. ;;; Keyword parsing.  This is special-cased here so that we can compile
  62. ;;; this file independent from cl-macs.
  63.  
  64. (defmacro cl-parsing-keywords (kwords other-keys &rest body)
  65.   (cons
  66.    'let*
  67.    (cons (mapcar
  68.       (function
  69.        (lambda (x)
  70.          (let* ((var (if (consp x) (car x) x))
  71.             (mem (list 'car (list 'cdr (list 'memq (list 'quote var)
  72.                              'cl-keys)))))
  73.            (if (eq var ':test-not)
  74.            (setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
  75.            (if (eq var ':if-not)
  76.            (setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
  77.            (list (intern
  78.               (format "cl-%s" (substring (symbol-name var) 1)))
  79.              (if (consp x) (list 'or mem (car (cdr x))) mem)))))
  80.       kwords)
  81.      (append
  82.       (and (not (eq other-keys t))
  83.            (list
  84.         (list 'let '((cl-keys-temp cl-keys))
  85.               (list 'while 'cl-keys-temp
  86.                 (list 'or (list 'memq '(car cl-keys-temp)
  87.                         (list 'quote
  88.                           (mapcar
  89.                            (function
  90.                             (lambda (x)
  91.                               (if (consp x)
  92.                               (car x) x)))
  93.                            (append kwords
  94.                                other-keys))))
  95.                   '(car (cdr (memq (quote :allow-other-keys)
  96.                            cl-keys)))
  97.                   '(error "Bad keyword argument %s"
  98.                       (car cl-keys-temp)))
  99.                 '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
  100.       body))))
  101. (put 'cl-parsing-keywords 'lisp-indent-function 2)
  102. (put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form))
  103.  
  104. (defmacro cl-check-key (x)
  105.   (list 'if 'cl-key (list 'funcall 'cl-key x) x))
  106.  
  107. (defmacro cl-check-test-nokey (item x)
  108.   (list 'cond
  109.     (list 'cl-test
  110.           (list 'eq (list 'not (list 'funcall 'cl-test item x))
  111.             'cl-test-not))
  112.     (list 'cl-if
  113.           (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not))
  114.     (list 't (list 'if (list 'numberp item)
  115.                (list 'equal item x) (list 'eq item x)))))
  116.  
  117. (defmacro cl-check-test (item x)
  118.   (list 'cl-check-test-nokey item (list 'cl-check-key x)))
  119.  
  120. (defmacro cl-check-match (x y)
  121.   (setq x (list 'cl-check-key x) y (list 'cl-check-key y))
  122.   (list 'if 'cl-test
  123.     (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
  124.     (list 'if (list 'numberp x)
  125.           (list 'equal x y) (list 'eq x y))))
  126.  
  127. (put 'cl-check-key 'edebug-form-spec 'edebug-forms)
  128. (put 'cl-check-test 'edebug-form-spec 'edebug-forms)
  129. (put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms)
  130. (put 'cl-check-match 'edebug-form-spec 'edebug-forms)
  131.  
  132. (defvar cl-test) (defvar cl-test-not)
  133. (defvar cl-if) (defvar cl-if-not)
  134. (defvar cl-key)
  135.  
  136.  
  137. (defun reduce (cl-func cl-seq &rest cl-keys)
  138.   "Reduce two-argument FUNCTION across SEQUENCE.
  139. Keywords supported:  :start :end :from-end :initial-value :key"
  140.   (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
  141.     (or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
  142.     (setq cl-seq (subseq cl-seq cl-start cl-end))
  143.     (if cl-from-end (setq cl-seq (nreverse cl-seq)))
  144.     (let ((cl-accum (cond ((memq ':initial-value cl-keys) cl-initial-value)
  145.               (cl-seq (cl-check-key (cl-pop cl-seq)))
  146.               (t (funcall cl-func)))))
  147.       (if cl-from-end
  148.       (while cl-seq
  149.         (setq cl-accum (funcall cl-func (cl-check-key (cl-pop cl-seq))
  150.                     cl-accum)))
  151.     (while cl-seq
  152.       (setq cl-accum (funcall cl-func cl-accum
  153.                   (cl-check-key (cl-pop cl-seq))))))
  154.       cl-accum)))
  155.  
  156. (defun fill (seq item &rest cl-keys)
  157.   "Fill the elements of SEQ with ITEM.
  158. Keywords supported:  :start :end"
  159.   (cl-parsing-keywords ((:start 0) :end) ()
  160.     (if (listp seq)
  161.     (let ((p (nthcdr cl-start seq))
  162.           (n (if cl-end (- cl-end cl-start) 8000000)))
  163.       (while (and p (>= (setq n (1- n)) 0))
  164.         (setcar p item)
  165.         (setq p (cdr p))))
  166.       (or cl-end (setq cl-end (length seq)))
  167.       (if (and (= cl-start 0) (= cl-end (length seq)))
  168.       (fillarray seq item)
  169.     (while (< cl-start cl-end)
  170.       (aset seq cl-start item)
  171.       (setq cl-start (1+ cl-start)))))
  172.     seq))
  173.  
  174. (defun replace (cl-seq1 cl-seq2 &rest cl-keys)
  175.   "Replace the elements of SEQ1 with the elements of SEQ2.
  176. SEQ1 is destructively modified, then returned.
  177. Keywords supported:  :start1 :end1 :start2 :end2"
  178.   (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
  179.     (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
  180.     (or (= cl-start1 cl-start2)
  181.         (let* ((cl-len (length cl-seq1))
  182.            (cl-n (min (- (or cl-end1 cl-len) cl-start1)
  183.                   (- (or cl-end2 cl-len) cl-start2))))
  184.           (while (>= (setq cl-n (1- cl-n)) 0)
  185.         (cl-set-elt cl-seq1 (+ cl-start1 cl-n)
  186.                 (elt cl-seq2 (+ cl-start2 cl-n))))))
  187.       (if (listp cl-seq1)
  188.       (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
  189.         (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000)))
  190.         (if (listp cl-seq2)
  191.         (let ((cl-p2 (nthcdr cl-start2 cl-seq2))
  192.               (cl-n (min cl-n1
  193.                  (if cl-end2 (- cl-end2 cl-start2) 4000000))))
  194.           (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0))
  195.             (setcar cl-p1 (car cl-p2))
  196.             (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))))
  197.           (setq cl-end2 (min (or cl-end2 (length cl-seq2))
  198.                  (+ cl-start2 cl-n1)))
  199.           (while (and cl-p1 (< cl-start2 cl-end2))
  200.         (setcar cl-p1 (aref cl-seq2 cl-start2))
  201.         (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2)))))
  202.     (setq cl-end1 (min (or cl-end1 (length cl-seq1))
  203.                (+ cl-start1 (- (or cl-end2 (length cl-seq2))
  204.                        cl-start2))))
  205.     (if (listp cl-seq2)
  206.         (let ((cl-p2 (nthcdr cl-start2 cl-seq2)))
  207.           (while (< cl-start1 cl-end1)
  208.         (aset cl-seq1 cl-start1 (car cl-p2))
  209.         (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1))))
  210.       (while (< cl-start1 cl-end1)
  211.         (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2))
  212.         (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1))))))
  213.     cl-seq1))
  214.  
  215. (defun remove* (cl-item cl-seq &rest cl-keys)
  216.   "Remove all occurrences of ITEM in SEQ.
  217. This is a non-destructive function; it makes a copy of SEQ if necessary
  218. to avoid corrupting the original SEQ.
  219. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  220.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
  221.             (:start 0) :end) ()
  222.     (if (<= (or cl-count (setq cl-count 8000000)) 0)
  223.     cl-seq
  224.       (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000)))
  225.       (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end
  226.                    cl-from-end)))
  227.         (if cl-i
  228.         (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
  229.                      (append (if cl-from-end
  230.                          (list ':end (1+ cl-i))
  231.                            (list ':start cl-i))
  232.                          cl-keys))))
  233.           (if (listp cl-seq) cl-res
  234.             (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))
  235.           cl-seq))
  236.     (setq cl-end (- (or cl-end 8000000) cl-start))
  237.     (if (= cl-start 0)
  238.         (while (and cl-seq (> cl-end 0)
  239.             (cl-check-test cl-item (car cl-seq))
  240.             (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
  241.             (> (setq cl-count (1- cl-count)) 0))))
  242.     (if (and (> cl-count 0) (> cl-end 0))
  243.         (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
  244.               (setq cl-end (1- cl-end)) (cdr cl-seq))))
  245.           (while (and cl-p (> cl-end 0)
  246.               (not (cl-check-test cl-item (car cl-p))))
  247.         (setq cl-p (cdr cl-p) cl-end (1- cl-end)))
  248.           (if (and cl-p (> cl-end 0))
  249.           (nconc (ldiff cl-seq cl-p)
  250.              (if (= cl-count 1) (cdr cl-p)
  251.                (and (cdr cl-p)
  252.                 (apply 'delete* cl-item
  253.                        (copy-sequence (cdr cl-p))
  254.                        ':start 0 ':end (1- cl-end)
  255.                        ':count (1- cl-count) cl-keys))))
  256.         cl-seq))
  257.       cl-seq)))))
  258.  
  259. (defun remove-if (cl-pred cl-list &rest cl-keys)
  260.   "Remove all items satisfying PREDICATE in SEQ.
  261. This is a non-destructive function; it makes a copy of SEQ if necessary
  262. to avoid corrupting the original SEQ.
  263. Keywords supported:  :key :count :start :end :from-end"
  264.   (apply 'remove* nil cl-list ':if cl-pred cl-keys))
  265.  
  266. (defun remove-if-not (cl-pred cl-list &rest cl-keys)
  267.   "Remove all items not satisfying PREDICATE in SEQ.
  268. This is a non-destructive function; it makes a copy of SEQ if necessary
  269. to avoid corrupting the original SEQ.
  270. Keywords supported:  :key :count :start :end :from-end"
  271.   (apply 'remove* nil cl-list ':if-not cl-pred cl-keys))
  272.  
  273. (defun delete* (cl-item cl-seq &rest cl-keys)
  274.   "Remove all occurrences of ITEM in SEQ.
  275. This is a destructive function; it reuses the storage of SEQ whenever possible.
  276. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  277.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
  278.             (:start 0) :end) ()
  279.     (if (<= (or cl-count (setq cl-count 8000000)) 0)
  280.     cl-seq
  281.       (if (listp cl-seq)
  282.       (if (and cl-from-end (< cl-count 4000000))
  283.           (let (cl-i)
  284.         (while (and (>= (setq cl-count (1- cl-count)) 0)
  285.                 (setq cl-i (cl-position cl-item cl-seq cl-start
  286.                             cl-end cl-from-end)))
  287.           (if (= cl-i 0) (setq cl-seq (cdr cl-seq))
  288.             (let ((cl-tail (nthcdr (1- cl-i) cl-seq)))
  289.               (setcdr cl-tail (cdr (cdr cl-tail)))))
  290.           (setq cl-end cl-i))
  291.         cl-seq)
  292.         (setq cl-end (- (or cl-end 8000000) cl-start))
  293.         (if (= cl-start 0)
  294.         (progn
  295.           (while (and cl-seq
  296.                   (> cl-end 0)
  297.                   (cl-check-test cl-item (car cl-seq))
  298.                   (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
  299.                   (> (setq cl-count (1- cl-count)) 0)))
  300.           (setq cl-end (1- cl-end)))
  301.           (setq cl-start (1- cl-start)))
  302.         (if (and (> cl-count 0) (> cl-end 0))
  303.         (let ((cl-p (nthcdr cl-start cl-seq)))
  304.           (while (and (cdr cl-p) (> cl-end 0))
  305.             (if (cl-check-test cl-item (car (cdr cl-p)))
  306.             (progn
  307.               (setcdr cl-p (cdr (cdr cl-p)))
  308.               (if (= (setq cl-count (1- cl-count)) 0)
  309.                   (setq cl-end 1)))
  310.               (setq cl-p (cdr cl-p)))
  311.             (setq cl-end (1- cl-end)))))
  312.         cl-seq)
  313.     (apply 'remove* cl-item cl-seq cl-keys)))))
  314.  
  315. (defun delete-if (cl-pred cl-list &rest cl-keys)
  316.   "Remove all items satisfying PREDICATE in SEQ.
  317. This is a destructive function; it reuses the storage of SEQ whenever possible.
  318. Keywords supported:  :key :count :start :end :from-end"
  319.   (apply 'delete* nil cl-list ':if cl-pred cl-keys))
  320.  
  321. (defun delete-if-not (cl-pred cl-list &rest cl-keys)
  322.   "Remove all items not satisfying PREDICATE in SEQ.
  323. This is a destructive function; it reuses the storage of SEQ whenever possible.
  324. Keywords supported:  :key :count :start :end :from-end"
  325.   (apply 'delete* nil cl-list ':if-not cl-pred cl-keys))
  326.  
  327. (or (and (fboundp 'delete) (subrp (symbol-function 'delete)))
  328.     (defalias 'delete (function (lambda (x y) (delete* x y ':test 'equal)))))
  329.  
  330. (defun remove (cl-item cl-seq)
  331.   "Remove all occurrences of ITEM in SEQ, testing with `equal'
  332. This is a non-destructive function; it makes a copy of SEQ if necessary
  333. to avoid corrupting the original SEQ.
  334. Also see: `remove*', `delete', `delete*'"
  335.   (remove* cl-item cl-seq ':test 'equal))
  336.  
  337. (defun remq (cl-elt cl-list)
  338.   "Remove all occurances of ELT in LIST, comparing with `eq'.
  339. This is a non-destructive function; it makes a copy of LIST to avoid
  340. corrupting the original LIST.
  341. Also see: `delq', `delete', `delete*', `remove', `remove*'."
  342.   (if (memq cl-elt cl-list)
  343.       (delq cl-elt (copy-list cl-list))
  344.     cl-list))
  345.  
  346. (defun remove-duplicates (cl-seq &rest cl-keys)
  347.   "Return a copy of SEQ with all duplicate elements removed.
  348. Keywords supported:  :test :test-not :key :start :end :from-end"
  349.   (cl-delete-duplicates cl-seq cl-keys t))
  350.  
  351. (defun delete-duplicates (cl-seq &rest cl-keys)
  352.   "Remove all duplicate elements from SEQ (destructively).
  353. Keywords supported:  :test :test-not :key :start :end :from-end"
  354.   (cl-delete-duplicates cl-seq cl-keys nil))
  355.  
  356. (defun cl-delete-duplicates (cl-seq cl-keys cl-copy)
  357.   (if (listp cl-seq)
  358.       (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if)
  359.       ()
  360.     (if cl-from-end
  361.         (let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
  362.           (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
  363.           (while (> cl-end 1)
  364.         (setq cl-i 0)
  365.         (while (setq cl-i (cl-position (cl-check-key (car cl-p))
  366.                            (cdr cl-p) cl-i (1- cl-end)))
  367.           (if cl-copy (setq cl-seq (copy-sequence cl-seq)
  368.                     cl-p (nthcdr cl-start cl-seq) cl-copy nil))
  369.           (let ((cl-tail (nthcdr cl-i cl-p)))
  370.             (setcdr cl-tail (cdr (cdr cl-tail))))
  371.           (setq cl-end (1- cl-end)))
  372.         (setq cl-p (cdr cl-p) cl-end (1- cl-end)
  373.               cl-start (1+ cl-start)))
  374.           cl-seq)
  375.       (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
  376.       (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
  377.               (cl-position (cl-check-key (car cl-seq))
  378.                    (cdr cl-seq) 0 (1- cl-end)))
  379.         (setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
  380.       (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
  381.             (setq cl-end (1- cl-end) cl-start 1) cl-seq)))
  382.         (while (and (cdr (cdr cl-p)) (> cl-end 1))
  383.           (if (cl-position (cl-check-key (car (cdr cl-p)))
  384.                    (cdr (cdr cl-p)) 0 (1- cl-end))
  385.           (progn
  386.             (if cl-copy (setq cl-seq (copy-sequence cl-seq)
  387.                       cl-p (nthcdr (1- cl-start) cl-seq)
  388.                       cl-copy nil))
  389.             (setcdr cl-p (cdr (cdr cl-p))))
  390.         (setq cl-p (cdr cl-p)))
  391.           (setq cl-end (1- cl-end) cl-start (1+ cl-start)))
  392.         cl-seq)))
  393.     (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil)))
  394.       (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))))
  395.  
  396. (defun substitute (cl-new cl-old cl-seq &rest cl-keys)
  397.   "Substitute NEW for OLD in SEQ.
  398. This is a non-destructive function; it makes a copy of SEQ if necessary
  399. to avoid corrupting the original SEQ.
  400. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  401.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count
  402.             (:start 0) :end :from-end) ()
  403.     (if (or (eq cl-old cl-new)
  404.         (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0))
  405.     cl-seq
  406.       (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end)))
  407.     (if (not cl-i)
  408.         cl-seq
  409.       (setq cl-seq (copy-sequence cl-seq))
  410.       (or cl-from-end
  411.           (progn (cl-set-elt cl-seq cl-i cl-new)
  412.              (setq cl-i (1+ cl-i) cl-count (1- cl-count))))
  413.       (apply 'nsubstitute cl-new cl-old cl-seq ':count cl-count
  414.          ':start cl-i cl-keys))))))
  415.  
  416. (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
  417.   "Substitute NEW for all items satisfying PREDICATE in SEQ.
  418. This is a non-destructive function; it makes a copy of SEQ if necessary
  419. to avoid corrupting the original SEQ.
  420. Keywords supported:  :key :count :start :end :from-end"
  421.   (apply 'substitute cl-new nil cl-list ':if cl-pred cl-keys))
  422.  
  423. (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
  424.   "Substitute NEW for all items not satisfying PREDICATE in SEQ.
  425. This is a non-destructive function; it makes a copy of SEQ if necessary
  426. to avoid corrupting the original SEQ.
  427. Keywords supported:  :key :count :start :end :from-end"
  428.   (apply 'substitute cl-new nil cl-list ':if-not cl-pred cl-keys))
  429.  
  430. (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
  431.   "Substitute NEW for OLD in SEQ.
  432. This is a destructive function; it reuses the storage of SEQ whenever possible.
  433. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  434.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count
  435.             (:start 0) :end :from-end) ()
  436.     (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0)
  437.     (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000)))
  438.         (let ((cl-p (nthcdr cl-start cl-seq)))
  439.           (setq cl-end (- (or cl-end 8000000) cl-start))
  440.           (while (and cl-p (> cl-end 0) (> cl-count 0))
  441.         (if (cl-check-test cl-old (car cl-p))
  442.             (progn
  443.               (setcar cl-p cl-new)
  444.               (setq cl-count (1- cl-count))))
  445.         (setq cl-p (cdr cl-p) cl-end (1- cl-end))))
  446.       (or cl-end (setq cl-end (length cl-seq)))
  447.       (if cl-from-end
  448.           (while (and (< cl-start cl-end) (> cl-count 0))
  449.         (setq cl-end (1- cl-end))
  450.         (if (cl-check-test cl-old (elt cl-seq cl-end))
  451.             (progn
  452.               (cl-set-elt cl-seq cl-end cl-new)
  453.               (setq cl-count (1- cl-count)))))
  454.         (while (and (< cl-start cl-end) (> cl-count 0))
  455.           (if (cl-check-test cl-old (aref cl-seq cl-start))
  456.           (progn
  457.             (aset cl-seq cl-start cl-new)
  458.             (setq cl-count (1- cl-count))))
  459.           (setq cl-start (1+ cl-start))))))
  460.     cl-seq))
  461.  
  462. (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
  463.   "Substitute NEW for all items satisfying PREDICATE in SEQ.
  464. This is a destructive function; it reuses the storage of SEQ whenever possible.
  465. Keywords supported:  :key :count :start :end :from-end"
  466.   (apply 'nsubstitute cl-new nil cl-list ':if cl-pred cl-keys))
  467.  
  468. (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
  469.   "Substitute NEW for all items not satisfying PREDICATE in SEQ.
  470. This is a destructive function; it reuses the storage of SEQ whenever possible.
  471. Keywords supported:  :key :count :start :end :from-end"
  472.   (apply 'nsubstitute cl-new nil cl-list ':if-not cl-pred cl-keys))
  473.  
  474. (defun find (cl-item cl-seq &rest cl-keys)
  475.   "Find the first occurrence of ITEM in LIST.
  476. Return the matching ITEM, or nil if not found.
  477. Keywords supported:  :test :test-not :key :start :end :from-end"
  478.   (let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
  479.     (and cl-pos (elt cl-seq cl-pos))))
  480.  
  481. (defun find-if (cl-pred cl-list &rest cl-keys)
  482.   "Find the first item satisfying PREDICATE in LIST.
  483. Return the matching ITEM, or nil if not found.
  484. Keywords supported:  :key :start :end :from-end"
  485.   (apply 'find nil cl-list ':if cl-pred cl-keys))
  486.  
  487. (defun find-if-not (cl-pred cl-list &rest cl-keys)
  488.   "Find the first item not satisfying PREDICATE in LIST.
  489. Return the matching ITEM, or nil if not found.
  490. Keywords supported:  :key :start :end :from-end"
  491.   (apply 'find nil cl-list ':if-not cl-pred cl-keys))
  492.  
  493. (defun position (cl-item cl-seq &rest cl-keys)
  494.   "Find the first occurrence of ITEM in LIST.
  495. Return the index of the matching item, or nil if not found.
  496. Keywords supported:  :test :test-not :key :start :end :from-end"
  497.   (cl-parsing-keywords (:test :test-not :key :if :if-not
  498.             (:start 0) :end :from-end) ()
  499.     (cl-position cl-item cl-seq cl-start cl-end cl-from-end)))
  500.  
  501. (defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end)
  502.   (if (listp cl-seq)
  503.       (let ((cl-p (nthcdr cl-start cl-seq)))
  504.     (or cl-end (setq cl-end 8000000))
  505.     (let ((cl-res nil))
  506.       (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
  507.         (if (cl-check-test cl-item (car cl-p))
  508.         (setq cl-res cl-start))
  509.         (setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
  510.       cl-res))
  511.     (or cl-end (setq cl-end (length cl-seq)))
  512.     (if cl-from-end
  513.     (progn
  514.       (while (and (>= (setq cl-end (1- cl-end)) cl-start)
  515.               (not (cl-check-test cl-item (aref cl-seq cl-end)))))
  516.       (and (>= cl-end cl-start) cl-end))
  517.       (while (and (< cl-start cl-end)
  518.           (not (cl-check-test cl-item (aref cl-seq cl-start))))
  519.     (setq cl-start (1+ cl-start)))
  520.       (and (< cl-start cl-end) cl-start))))
  521.  
  522. (defun position-if (cl-pred cl-list &rest cl-keys)
  523.   "Find the first item satisfying PREDICATE in LIST.
  524. Return the index of the matching item, or nil if not found.
  525. Keywords supported:  :key :start :end :from-end"
  526.   (apply 'position nil cl-list ':if cl-pred cl-keys))
  527.  
  528. (defun position-if-not (cl-pred cl-list &rest cl-keys)
  529.   "Find the first item not satisfying PREDICATE in LIST.
  530. Return the index of the matching item, or nil if not found.
  531. Keywords supported:  :key :start :end :from-end"
  532.   (apply 'position nil cl-list ':if-not cl-pred cl-keys))
  533.  
  534. (defun count (cl-item cl-seq &rest cl-keys)
  535.   "Count the number of occurrences of ITEM in LIST.
  536. Keywords supported:  :test :test-not :key :start :end"
  537.   (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
  538.     (let ((cl-count 0) cl-x)
  539.       (or cl-end (setq cl-end (length cl-seq)))
  540.       (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
  541.       (while (< cl-start cl-end)
  542.     (setq cl-x (if (consp cl-seq) (cl-pop cl-seq) (aref cl-seq cl-start)))
  543.     (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
  544.     (setq cl-start (1+ cl-start)))
  545.       cl-count)))
  546.  
  547. (defun count-if (cl-pred cl-list &rest cl-keys)
  548.   "Count the number of items satisfying PREDICATE in LIST.
  549. Keywords supported:  :key :start :end"
  550.   (apply 'count nil cl-list ':if cl-pred cl-keys))
  551.  
  552. (defun count-if-not (cl-pred cl-list &rest cl-keys)
  553.   "Count the number of items not satisfying PREDICATE in LIST.
  554. Keywords supported:  :key :start :end"
  555.   (apply 'count nil cl-list ':if-not cl-pred cl-keys))
  556.  
  557. (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
  558.   "Compare SEQ1 with SEQ2, return index of first mismatching element.
  559. Return nil if the sequences match.  If one sequence is a prefix of the
  560. other, the return value indicates the end of the shorted sequence.
  561. Keywords supported:  :test :test-not :key :start1 :end1 :start2 :end2 :from-end"
  562.   (cl-parsing-keywords (:test :test-not :key :from-end
  563.             (:start1 0) :end1 (:start2 0) :end2) ()
  564.     (or cl-end1 (setq cl-end1 (length cl-seq1)))
  565.     (or cl-end2 (setq cl-end2 (length cl-seq2)))
  566.     (if cl-from-end
  567.     (progn
  568.       (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
  569.               (cl-check-match (elt cl-seq1 (1- cl-end1))
  570.                       (elt cl-seq2 (1- cl-end2))))
  571.         (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
  572.       (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
  573.            (1- cl-end1)))
  574.       (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
  575.         (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
  576.     (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
  577.             (cl-check-match (if cl-p1 (car cl-p1)
  578.                       (aref cl-seq1 cl-start1))
  579.                     (if cl-p2 (car cl-p2)
  580.                       (aref cl-seq2 cl-start2))))
  581.       (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
  582.         cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
  583.     (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
  584.          cl-start1)))))
  585.  
  586. (defun search (cl-seq1 cl-seq2 &rest cl-keys)
  587.   "Search for SEQ1 as a subsequence of SEQ2.
  588. Return the index of the leftmost element of the first match found;
  589. return nil if there are no matches.
  590. Keywords supported:  :test :test-not :key :start1 :end1 :start2 :end2 :from-end"
  591.   (cl-parsing-keywords (:test :test-not :key :from-end
  592.             (:start1 0) :end1 (:start2 0) :end2) ()
  593.     (or cl-end1 (setq cl-end1 (length cl-seq1)))
  594.     (or cl-end2 (setq cl-end2 (length cl-seq2)))
  595.     (if (>= cl-start1 cl-end1)
  596.     (if cl-from-end cl-end2 cl-start2)
  597.       (let* ((cl-len (- cl-end1 cl-start1))
  598.          (cl-first (cl-check-key (elt cl-seq1 cl-start1)))
  599.          (cl-if nil) cl-pos)
  600.     (setq cl-end2 (- cl-end2 (1- cl-len)))
  601.     (while (and (< cl-start2 cl-end2)
  602.             (setq cl-pos (cl-position cl-first cl-seq2
  603.                           cl-start2 cl-end2 cl-from-end))
  604.             (apply 'mismatch cl-seq1 cl-seq2
  605.                ':start1 (1+ cl-start1) ':end1 cl-end1
  606.                ':start2 (1+ cl-pos) ':end2 (+ cl-pos cl-len)
  607.                ':from-end nil cl-keys))
  608.       (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
  609.     (and (< cl-start2 cl-end2) cl-pos)))))
  610.  
  611. (defun sort* (cl-seq cl-pred &rest cl-keys)
  612.   "Sort the argument SEQUENCE according to PREDICATE.
  613. This is a destructive function; it reuses the storage of SEQUENCE if possible.
  614. Keywords supported:  :key"
  615.   (if (nlistp cl-seq)
  616.       (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys))
  617.     (cl-parsing-keywords (:key) ()
  618.       (if (memq cl-key '(nil identity))
  619.       (sort cl-seq cl-pred)
  620.     (sort cl-seq (function (lambda (cl-x cl-y)
  621.                  (funcall cl-pred (funcall cl-key cl-x)
  622.                       (funcall cl-key cl-y)))))))))
  623.  
  624. (defun stable-sort (cl-seq cl-pred &rest cl-keys)
  625.   "Sort the argument SEQUENCE stably according to PREDICATE.
  626. This is a destructive function; it reuses the storage of SEQUENCE if possible.
  627. Keywords supported:  :key"
  628.   (apply 'sort* cl-seq cl-pred cl-keys))
  629.  
  630. (defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
  631.   "Destructively merge the two sequences to produce a new sequence.
  632. TYPE is the sequence type to return, SEQ1 and SEQ2 are the two
  633. argument sequences, and PRED is a `less-than' predicate on the elements.
  634. Keywords supported:  :key"
  635.   (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil)))
  636.   (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil)))
  637.   (cl-parsing-keywords (:key) ()
  638.     (let ((cl-res nil))
  639.       (while (and cl-seq1 cl-seq2)
  640.     (if (funcall cl-pred (cl-check-key (car cl-seq2))
  641.              (cl-check-key (car cl-seq1)))
  642.         (cl-push (cl-pop cl-seq2) cl-res)
  643.       (cl-push (cl-pop cl-seq1) cl-res)))
  644.       (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
  645.  
  646. ;;; See compiler macro in cl-macs.el
  647. (defun member* (cl-item cl-list &rest cl-keys)
  648.   "Find the first occurrence of ITEM in LIST.
  649. Return the sublist of LIST whose car is ITEM.
  650. Keywords supported:  :test :test-not :key"
  651.   (if cl-keys
  652.       (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  653.     (while (and cl-list (not (cl-check-test cl-item (car cl-list))))
  654.       (setq cl-list (cdr cl-list)))
  655.     cl-list)
  656.     (if (and (numberp cl-item) (not (integerp cl-item)))
  657.     (member cl-item cl-list)
  658.       (memq cl-item cl-list))))
  659.  
  660. (defun member-if (cl-pred cl-list &rest cl-keys)
  661.   "Find the first item satisfying PREDICATE in LIST.
  662. Return the sublist of LIST whose car matches.
  663. Keywords supported:  :key"
  664.   (apply 'member* nil cl-list ':if cl-pred cl-keys))
  665.  
  666. (defun member-if-not (cl-pred cl-list &rest cl-keys)
  667.   "Find the first item not satisfying PREDICATE in LIST.
  668. Return the sublist of LIST whose car matches.
  669. Keywords supported:  :key"
  670.   (apply 'member* nil cl-list ':if-not cl-pred cl-keys))
  671.  
  672. (defun cl-adjoin (cl-item cl-list &rest cl-keys)
  673.   (if (cl-parsing-keywords (:key) t
  674.     (apply 'member* (cl-check-key cl-item) cl-list cl-keys))
  675.       cl-list
  676.     (cons cl-item cl-list)))
  677.  
  678. ;;; See compiler macro in cl-macs.el
  679. (defun assoc* (cl-item cl-alist &rest cl-keys)
  680.   "Find the first item whose car matches ITEM in LIST.
  681. Keywords supported:  :test :test-not :key"
  682.   (if cl-keys
  683.       (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  684.     (while (and cl-alist
  685.             (or (not (consp (car cl-alist)))
  686.             (not (cl-check-test cl-item (car (car cl-alist))))))
  687.       (setq cl-alist (cdr cl-alist)))
  688.     (and cl-alist (car cl-alist)))
  689.     (if (and (numberp cl-item) (not (integerp cl-item)))
  690.     (assoc cl-item cl-alist)
  691.       (assq cl-item cl-alist))))
  692.  
  693. (defun assoc-if (cl-pred cl-list &rest cl-keys)
  694.   "Find the first item whose car satisfies PREDICATE in LIST.
  695. Keywords supported:  :key"
  696.   (apply 'assoc* nil cl-list ':if cl-pred cl-keys))
  697.  
  698. (defun assoc-if-not (cl-pred cl-list &rest cl-keys)
  699.   "Find the first item whose car does not satisfy PREDICATE in LIST.
  700. Keywords supported:  :key"
  701.   (apply 'assoc* nil cl-list ':if-not cl-pred cl-keys))
  702.  
  703. (defun rassoc* (cl-item cl-alist &rest cl-keys)
  704.   "Find the first item whose cdr matches ITEM in LIST.
  705. Keywords supported:  :test :test-not :key"
  706.   (if (or cl-keys (numberp cl-item))
  707.       (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  708.     (while (and cl-alist
  709.             (or (not (consp (car cl-alist)))
  710.             (not (cl-check-test cl-item (cdr (car cl-alist))))))
  711.       (setq cl-alist (cdr cl-alist)))
  712.     (and cl-alist (car cl-alist)))
  713.     (rassq cl-item cl-alist)))
  714.  
  715. (defun rassoc-if (cl-pred cl-list &rest cl-keys)
  716.   "Find the first item whose cdr satisfies PREDICATE in LIST.
  717. Keywords supported:  :key"
  718.   (apply 'rassoc* nil cl-list ':if cl-pred cl-keys))
  719.  
  720. (defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
  721.   "Find the first item whose cdr does not satisfy PREDICATE in LIST.
  722. Keywords supported:  :key"
  723.   (apply 'rassoc* nil cl-list ':if-not cl-pred cl-keys))
  724.  
  725. (defun union (cl-list1 cl-list2 &rest cl-keys)
  726.   "Combine LIST1 and LIST2 using a set-union operation.
  727. The result list contains all items that appear in either LIST1 or LIST2.
  728. This is a non-destructive function; it makes a copy of the data if necessary
  729. to avoid corrupting the original LIST1 and LIST2.
  730. Keywords supported:  :test :test-not :key"
  731.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  732.     ((equal cl-list1 cl-list2) cl-list1)
  733.     (t
  734.      (or (>= (length cl-list1) (length cl-list2))
  735.          (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
  736.      (while cl-list2
  737.        (if (or cl-keys (numberp (car cl-list2)))
  738.            (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
  739.          (or (memq (car cl-list2) cl-list1)
  740.          (cl-push (car cl-list2) cl-list1)))
  741.        (cl-pop cl-list2))
  742.      cl-list1)))
  743.  
  744. (defun nunion (cl-list1 cl-list2 &rest cl-keys)
  745.   "Combine LIST1 and LIST2 using a set-union operation.
  746. The result list contains all items that appear in either LIST1 or LIST2.
  747. This is a destructive function; it reuses the storage of LIST1 and LIST2
  748. whenever possible.
  749. Keywords supported:  :test :test-not :key"
  750.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  751.     (t (apply 'union cl-list1 cl-list2 cl-keys))))
  752.  
  753. (defun intersection (cl-list1 cl-list2 &rest cl-keys)
  754.   "Combine LIST1 and LIST2 using a set-intersection operation.
  755. The result list contains all items that appear in both LIST1 and LIST2.
  756. This is a non-destructive function; it makes a copy of the data if necessary
  757. to avoid corrupting the original LIST1 and LIST2.
  758. Keywords supported:  :test :test-not :key"
  759.   (and cl-list1 cl-list2
  760.        (if (equal cl-list1 cl-list2) cl-list1
  761.      (cl-parsing-keywords (:key) (:test :test-not)
  762.        (let ((cl-res nil))
  763.          (or (>= (length cl-list1) (length cl-list2))
  764.          (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
  765.          (while cl-list2
  766.            (if (if (or cl-keys (numberp (car cl-list2)))
  767.                (apply 'member* (cl-check-key (car cl-list2))
  768.                   cl-list1 cl-keys)
  769.              (memq (car cl-list2) cl-list1))
  770.            (cl-push (car cl-list2) cl-res))
  771.            (cl-pop cl-list2))
  772.          cl-res)))))
  773.  
  774. (defun nintersection (cl-list1 cl-list2 &rest cl-keys)
  775.   "Combine LIST1 and LIST2 using a set-intersection operation.
  776. The result list contains all items that appear in both LIST1 and LIST2.
  777. This is a destructive function; it reuses the storage of LIST1 and LIST2
  778. whenever possible.
  779. Keywords supported:  :test :test-not :key"
  780.   (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
  781.  
  782. (defun set-difference (cl-list1 cl-list2 &rest cl-keys)
  783.   "Combine LIST1 and LIST2 using a set-difference operation.
  784. The result list contains all items that appear in LIST1 but not LIST2.
  785. This is a non-destructive function; it makes a copy of the data if necessary
  786. to avoid corrupting the original LIST1 and LIST2.
  787. Keywords supported:  :test :test-not :key"
  788.   (if (or (null cl-list1) (null cl-list2)) cl-list1
  789.     (cl-parsing-keywords (:key) (:test :test-not)
  790.       (let ((cl-res nil))
  791.     (while cl-list1
  792.       (or (if (or cl-keys (numberp (car cl-list1)))
  793.           (apply 'member* (cl-check-key (car cl-list1))
  794.              cl-list2 cl-keys)
  795.         (memq (car cl-list1) cl-list2))
  796.           (cl-push (car cl-list1) cl-res))
  797.       (cl-pop cl-list1))
  798.     cl-res))))
  799.  
  800. (defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
  801.   "Combine LIST1 and LIST2 using a set-difference operation.
  802. The result list contains all items that appear in LIST1 but not LIST2.
  803. This is a destructive function; it reuses the storage of LIST1 and LIST2
  804. whenever possible.
  805. Keywords supported:  :test :test-not :key"
  806.   (if (or (null cl-list1) (null cl-list2)) cl-list1
  807.     (apply 'set-difference cl-list1 cl-list2 cl-keys)))
  808.  
  809. (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
  810.   "Combine LIST1 and LIST2 using a set-exclusive-or operation.
  811. The result list contains all items that appear in exactly one of LIST1, LIST2.
  812. This is a non-destructive function; it makes a copy of the data if necessary
  813. to avoid corrupting the original LIST1 and LIST2.
  814. Keywords supported:  :test :test-not :key"
  815.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  816.     ((equal cl-list1 cl-list2) nil)
  817.     (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
  818.            (apply 'set-difference cl-list2 cl-list1 cl-keys)))))
  819.  
  820. (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
  821.   "Combine LIST1 and LIST2 using a set-exclusive-or operation.
  822. The result list contains all items that appear in exactly one of LIST1, LIST2.
  823. This is a destructive function; it reuses the storage of LIST1 and LIST2
  824. whenever possible.
  825. Keywords supported:  :test :test-not :key"
  826.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  827.     ((equal cl-list1 cl-list2) nil)
  828.     (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
  829.           (apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
  830.  
  831. (defun subsetp (cl-list1 cl-list2 &rest cl-keys)
  832.   "True if LIST1 is a subset of LIST2.
  833. I.e., if every element of LIST1 also appears in LIST2.
  834. Keywords supported:  :test :test-not :key"
  835.   (cond ((null cl-list1) t) ((null cl-list2) nil)
  836.     ((equal cl-list1 cl-list2) t)
  837.     (t (cl-parsing-keywords (:key) (:test :test-not)
  838.          (while (and cl-list1
  839.              (apply 'member* (cl-check-key (car cl-list1))
  840.                 cl-list2 cl-keys))
  841.            (cl-pop cl-list1))
  842.          (null cl-list1)))))
  843.  
  844. (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
  845.   "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
  846. Return a copy of TREE with all matching elements replaced by NEW.
  847. Keywords supported:  :key"
  848.   (apply 'sublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys))
  849.  
  850. (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
  851.   "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
  852. Return a copy of TREE with all non-matching elements replaced by NEW.
  853. Keywords supported:  :key"
  854.   (apply 'sublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys))
  855.  
  856. (defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
  857.   "Substitute NEW for OLD everywhere in TREE (destructively).
  858. Any element of TREE which is `eql' to OLD is changed to NEW (via a call
  859. to `setcar').
  860. Keywords supported:  :test :test-not :key"
  861.   (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
  862.  
  863. (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
  864.   "Substitute NEW for elements matching PREDICATE in TREE (destructively).
  865. Any element of TREE which matches is changed to NEW (via a call to `setcar').
  866. Keywords supported:  :key"
  867.   (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys))
  868.  
  869. (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
  870.   "Substitute NEW for elements not matching PREDICATE in TREE (destructively).
  871. Any element of TREE which matches is changed to NEW (via a call to `setcar').
  872. Keywords supported:  :key"
  873.   (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys))
  874.  
  875. (defun sublis (cl-alist cl-tree &rest cl-keys)
  876.   "Perform substitutions indicated by ALIST in TREE (non-destructively).
  877. Return a copy of TREE with all matching elements replaced.
  878. Keywords supported:  :test :test-not :key"
  879.   (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  880.     (cl-sublis-rec cl-tree)))
  881.  
  882. (defvar cl-alist)
  883. (defun cl-sublis-rec (cl-tree)   ; uses cl-alist/key/test*/if*
  884.   (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist))
  885.     (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
  886.       (setq cl-p (cdr cl-p)))
  887.     (if cl-p (cdr (car cl-p))
  888.       (if (consp cl-tree)
  889.       (let ((cl-a (cl-sublis-rec (car cl-tree)))
  890.         (cl-d (cl-sublis-rec (cdr cl-tree))))
  891.         (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
  892.         cl-tree
  893.           (cons cl-a cl-d)))
  894.     cl-tree))))
  895.  
  896. (defun nsublis (cl-alist cl-tree &rest cl-keys)
  897.   "Perform substitutions indicated by ALIST in TREE (destructively).
  898. Any matching element of TREE is changed via a call to `setcar'.
  899. Keywords supported:  :test :test-not :key"
  900.   (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  901.     (let ((cl-hold (list cl-tree)))
  902.       (cl-nsublis-rec cl-hold)
  903.       (car cl-hold))))
  904.  
  905. (defun cl-nsublis-rec (cl-tree)   ; uses cl-alist/temp/p/key/test*/if*
  906.   (while (consp cl-tree)
  907.     (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist))
  908.       (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
  909.     (setq cl-p (cdr cl-p)))
  910.       (if cl-p (setcar cl-tree (cdr (car cl-p)))
  911.     (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree))))
  912.       (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist)
  913.       (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
  914.     (setq cl-p (cdr cl-p)))
  915.       (if cl-p
  916.       (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
  917.     (setq cl-tree (cdr cl-tree))))))
  918.  
  919. (defun tree-equal (cl-x cl-y &rest cl-keys)
  920.   "T if trees X and Y have `eql' leaves.
  921. Atoms are compared by `eql'; cons cells are compared recursively.
  922. Keywords supported:  :test :test-not :key"
  923.   (cl-parsing-keywords (:test :test-not :key) ()
  924.     (cl-tree-equal-rec cl-x cl-y)))
  925.  
  926. (defun cl-tree-equal-rec (cl-x cl-y)
  927.   (while (and (consp cl-x) (consp cl-y)
  928.           (cl-tree-equal-rec (car cl-x) (car cl-y)))
  929.     (setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
  930.   (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
  931.  
  932.  
  933. (run-hooks 'cl-seq-load-hook)
  934.  
  935. ;;; cl-seq.el ends here
  936.